;; collection/string.scm - (c) rohan drape, 2001-2005

;; SRFI-13 variants.

;; Tokenize `s' at the <char> `c'.

(define (string-tokenizeC s c)
  (string-tokenize s (char-set-complement (char-set c))))

;; The character `n' places from the end of `s'.

(define (string-ref-right s n) (string-ref s (- (- (string-length s) n) 1)))

;; Evaluate to a new string that is at least `n' places long, has the
;; string `s' as a complete initial substring, and the character `c'
;; in all other locations.  This is similar to the SRFI-13 procedure
;; 'string-pad-right', however it does not trucate strings longer than
;; `n'.

(define (string-pad-right-safe s n c)
  (let ((s-n (string-length s)))
    (if (>= s-n n)
	s
	(let ((ss (make-string n c)))
	  (string-xcopy! ss 0 s 0 s-n)
	  ss))))

;; R5RS port operations over strings using SRFI string ports.

(define (call-with-input-string s p) 
  (p (open-input-string s)))

(define (with-input-from-string s p)
  (parameterize ((current-input-port (open-input-string s)))
		(p)))

(define (call-with-output-string p)
  (let ((s (open-output-string)))
    (p s)
    (get-output-string s)))

(define (with-output-to-string p)
  (let ((s (open-output-string)))
    (parameterize ((current-output-port s)) (p))
    (get-output-string s)))

(define close-output-string get-output-string)

;; Capitalize first character at `s', and downcase all other characters.

(define (string-capitalize s)
  (string-append (string (char-upcase (string-ref s 0)))
		 (string-map char-downcase (substring s 1))))

;; Evaluates to a string having at most the first `l' characters of
;; `s'.  If `s' has less than `l' characters evaluates to `s'.

(define (string-limit s l)
  (if (> (string-length s) l)
      (string-take s l)
      s))

;; Abbreviate the string `input' to have at most `n' characters.  The
;; algorithm uses a sequence of passes removing characters from the
;; right of the string and in all cases preserving the first character
;; and any integers.  The passes remove: 1. white space and
;; punctuation, 2. lower case vowels, 3. upper case vowels, 4. lower
;; case consonants, 5. upper case consonants.

(define (string-abbreviate input n)
  (let ((x (- n 1)))
    (let loop ((l (reverse (cdr (string->list input))))
	       (m '("\"\n\t ,<.>/?:;'[{}]~`!@#$%^&*()_-+="
		    "aeiou" 
		    "AEIOU" 
		    "bcdfghjklmnpqrtvwxyz" 
		    "BCDFGHJKLMNPQRTVWXYZ")))
      (let ((s (length l)))
	(if (> s x)
	    (loop (remove-count 
		   (lambda (c) 
		     (member c (string->list (car m))))
		   l
		   (- s x))
		  (cdr m))
	    (list->string (cons (string-ref input 0) (reverse l))))))))

;; Convert a <string> to a <vector> of <char>acters.

(define (string->vector s)
  (let* ((l (string-length s))
	 (v (make-vector l)))
    (do ((i 0 (+ i 1)))
	((= i l))
      (vector-set! v i (string-ref s i)))
    v))

;; Convert a <string> to a <vector> of integers (bytes).

(define (string->integer-vector s)
  (let* ((l (string-length s))
	 (v (make-vector l)))
    (do ((i 0 (+ i 1)))
	((= i l))
      (vector-set! v i (char->integer (string-ref s i))))
    v))

;; Convert a <vector> of <char>acters to a <string>.

(define (vector->string v)
  (let* ((l (vector-length v))
	 (s (make-string l)))
    (do ((i 0 (+ i 1)))
	((= i l))
      (string-set! s i (vector-ref v i)))
    s))

;; Convert a <vector> of <integer>s to a <string>.

(define (integer-vector->string v)
  (let* ((l (vector-length v))
	 (s (make-string l)))
    (do ((i 0 (+ i 1)))
	((= i l))
      (string-set! s i (integer->char (vector-ref v i))))
    s))

;; Three state comparison procedure.

(define (string-tsc a b)
  (if (string=? a b) 0 (if (string<? a b) -1 1)))

;; Use 'number->string' to make `n' into a string and then truncate to
;; `limit' decimal places.  Allows for exponential notation.

(define (real->string n limit)
  (let* ((s (number->string (exact->inexact n)))
	 (l (string-length s))
	 (dot-index (string-index s #\.))
	 (e-index (string-index s #\e)))
    (if (and dot-index (> (- (if e-index e-index l) dot-index) limit))
	(if e-index 
	    (string-append (string-take s (+ 1 dot-index limit))
			   (string-take-right s (- l e-index)))
	    (string-take s (+ 1 dot-index limit)))
	s)))

;; Variant of string-for-each.

(define (string-iterate s p)
  (if (thunk? p)
      (integer-iterate (string-length s) p)
      (string-for-each p s)))

;; Evaluates to a randomly selected element of the string 's'.

(define (string-choose v)
  (string-ref v (randomI-zero-right (string-length v))))

;; A `Pascal' string is a ASCII compatible byte string prefixed by a
;; length count represented using a single byte.

(define (decode/scan-pascal-string b)
  (u8vector->string (u8vector-copy b 1 (+ (u8vector-ref b 0) 1))))

(define (encode-pascal-string s)
  (let ((b (string->u8vector s)))
    (u8vector-append (u8vector (u8vector-length b))
		     b)))

(define (read-pascal-string port)
  (u8vector->string (read-u8vector (read-uint8 port) port)))

(define (write-pascal-string s port)
  (write-u8vector (encode-pascal-string s) port))

;; A `C' string is a ASCII compatible byte string terminated by a NULL
;; character #x00.

(define (decode/scan-c-string b)
  (let loop ((i 0))
    (if (= (u8vector-ref b i) 0)
	(u8vector->string (u8vector-copy b 0 i))
	(loop (+ i 1)))))

(define (encode-c-string s)
  (let ((b (string->u8vector s)))
    (u8vector-append b (u8vector 0))))

(define (read-c-string port)
  (let loop ((b (read-uint8 port))
	     (l (list)))
    (if (= b 0)
	(list->string (reverse l))
	(loop (read-uint8 port) (cons (integer->char b) l)))))

(define (write-c-string s port)
  (write-u8vector (encode-c-string s) port))

